home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 7 / BBS in a Box - Macintosh - Volume VII (BBS in a Box) (January 1993).iso / Files / Hyper / N-O / New & Old.cpt / NewFileName.p < prev    next >
Text File  |  1987-10-31  |  7KB  |  261 lines
  1. {$R-              }
  2. {$S NewFileName }
  3.  
  4. (*** New Filename
  5.  
  6. This HyperCard XFunction will present the user with the standard
  7. SFPutFile dialog box and return the users responce to the caller
  8. as either a full path name of the new file or empty if canceled.
  9.  
  10. I have departed from the human interface guidelines for dialog
  11. boxes as the SFPutFile dialog will be centered in the hypercard
  12. window and not the screen.  My reson for this is that HyperCard 
  13. has only one window (ignoring message box, &c) within which many
  14. of the rules are broken so by placing the dialog centered on the
  15. window it clearly indicates the dialog has been presented do to 
  16. pressing a button.
  17.     
  18. Much of the code is a taken from the FileName XFunction by
  19.     
  20.     Steve Maller
  21.     Apple Computer Training Support
  22.     Copyright © 1987 Apple Computer
  23.     AppleLink: MALLER1
  24.  
  25. To compile and link with MPW and MPW Pascal
  26.     
  27.     pascal -w NewFileName.p
  28.     
  29.     link -m ENTRYPOINT 
  30.          -rt XFCN=0 
  31.          -sn Main=NewFileName 
  32.          -o HyperCommands
  33.          NewFileName.p.o
  34.          Interface.o             
  35.          Paslib.o
  36.  
  37. A typical HyperTalk script calling NewFileName would be
  38.  
  39.     -- function NewFileName( <prompt>, <initial filename> ): <filename>
  40.  
  41.     on mouseUp
  42.         put NewFileName( "Save field as?", the name of field x ) into filename
  43.             
  44.         if filename is not empty then
  45.             open file filename
  46.             write field x to file filename
  47.             close file filename
  48.         end if
  49.     end mouseDown
  50.     
  51. Written by
  52.     
  53.     Andrew Gilmartin
  54.     Academic & User Services, Box 1885
  55.     Brown University
  56.     Providence, Rhode Island 02912
  57.     Copyright © 1987 Brown University
  58.     bitnet:  ANDREW@BROWNVM
  59.         
  60.     October 31, 1987 ***)
  61.  
  62.  
  63. unit newfilenameUnit;
  64.  
  65.     interface
  66.  
  67.         uses memtypes, quickdraw, osintf, toolintf, packintf, hyperxcmd;
  68.  
  69.         procedure entrypoint(paramptr: xcmdptr);
  70.  
  71.     implementation
  72.  
  73.         procedure newfilename(paramptr: xcmdptr); forward;
  74.  
  75.         procedure entrypoint(paramptr: xcmdptr);
  76.         begin
  77.             newfilename(paramptr);
  78.         end(* entry point *);
  79.         
  80.         procedure newfilename;
  81.  
  82.             var fullpathname: str255;
  83.                 filename    : str255;
  84.                 prompt        : str255;
  85.                 reply        : sfreply;
  86.  
  87.             {$I xcmdglue.inc }
  88.  
  89.  
  90.             (**    Param To Num
  91.         
  92.             This function returns a long integer interpretation of 
  93.             a zero terminated string (c-string). **)
  94.             
  95.             function paramtonum( param: handle ): longInt;
  96.                 var Str: Str255;
  97.             begin
  98.                 zerotopas( param^, str );
  99.                 paramtonum := strtonum( str )
  100.             end(* ParamToNum *);
  101.             
  102.  
  103.             (**  CenterRect
  104.             
  105.             This function will return the point where the top left corner
  106.             of inside rectange should be placed inorder for it to be
  107.             centered within outside rectangle.
  108.                 
  109.             It is not checked that inside is indeed wholely inside of
  110.             outside **)
  111.             
  112.             function centerrect( outr, inr: rect ): point;
  113.                 var p: point;
  114.             begin
  115.                 p.v := outr.top  + (((outr.bottom - outr.top) - (inr.bottom  - inr.top)) div 2);
  116.                 p.h := outr.left + (((outr.right - outr.left) - (inr.right  - inr.left)) div 2);
  117.                 centerrect := p
  118.             end(* center rect *);
  119.  
  120.             
  121.             (**    Card Rect
  122.             
  123.             This function will return a rectangle that specifies where
  124.             the HyperCard window (aka this card) is upon the screen.
  125.             It should be noted that the position is determined by asking
  126.             HyperCard rather than calling toolbox routines. **)
  127.             
  128.             function cardrect: rect;
  129.                 var card: rect;
  130.             begin
  131.                 card.top    := ParamToNum( evalexpr( 'item two of loc of card window' ) );
  132.                 card.left   := ParamToNum( evalexpr( 'item one of loc of card window' ) );
  133.                 card.bottom := card.top  + 342;
  134.                 card.right  := card.left + 512;
  135.                 cardrect    := card
  136.             end(* card rect *);
  137.             
  138.             
  139.             (**    Dialog Rect
  140.             
  141.             This function returns a rectangle that specifies where the
  142.             SFPutFile dialog whould be placed upon the screen. **)
  143.             
  144.             function dialogrect: rect;
  145.                 var dialog: dialogthndl;
  146.             begin
  147.                 dialog       := dialogthndl( getresource( 'DLOG', putdlgid ) );
  148.                 dialogrect := dialog^^.boundsrect
  149.             end(* dialog rect *);
  150.             
  151.             
  152.             (**    Build Pathname
  153.             
  154.             This function will return the full pathname from the volume
  155.             reference number and filename.  This code is a taken from
  156.             Steve Maller's original XFunction "FileName". **)
  157.             
  158.             function buildpathname( volume:integer; filename: str255): Str255;
  159.                 var fullpathname: str255;
  160.                     name        : str255;
  161.                     err            : integer;
  162.                     mywdpb        : wdpbptr;
  163.                     mycpb        : cinfopbptr;
  164.                     mypb        : hparmblkptr;
  165.             begin
  166.             
  167.                 buildpathname := '';
  168.                 
  169.                 { 
  170.                 first we allocate some memory in the heap for the 
  171.                 parameter block. this could in theory work on the stack, 
  172.                 but in reality it makes no difference as we're entirely 
  173.                 modal (ugh) here...
  174.                 }
  175.                 mycpb  := cinfopbptr(newptr(sizeof(hparamblockrec)));
  176.                 if ord4(mycpb) <= 0 then
  177.                     exit(buildpathname);            { rats! bill didn't leave enough room }
  178.                 mywdpb := wdpbptr(mycpb);            { icky pascal type coercions follow }
  179.                 mypb   := hparmblkptr(mycpb);
  180.  
  181.  
  182.                 name := '';                         { start with an empty name }
  183.                 mypb^.ionameptr := @name;            { we want the volume name }
  184.                 mypb^.iocompletion := pointer(0);
  185.                 mypb^.iovrefnum := volume;            { returned from sfgetfile }
  186.                 mypb^.iovolindex := 0;                { use the vrefnum and name }
  187.                 err := pbhgetvinfo(mypb, false);    { fill in the volume info }
  188.                 if err <> noerr then
  189.                     exit(buildpathname);
  190.  
  191.                 {     
  192.                 now we need the working directory (wd) information 
  193.                 because we're going to step backwards from the file 
  194.                 through all of the the folders until we reach the 
  195.                 root directory
  196.                 }
  197.                 mywdpb^.iovrefnum := volume;        { this got set to 0 above }                    mywdpb^.iowdprocid := 0;                            { use the vrefnum }
  198.                 mywdpb^.iowdindex := 0;                { we want all directories }
  199.                 err := pbgetwdinfo(mywdpb, false);    { do it }
  200.                 if err <> noerr then
  201.                     exit(buildpathname);
  202.  
  203.                 mycpb^.iofdirindex := - 1;                { use the iodirid field only }
  204.                 mycpb^.iodrdirid := mywdpb^.iowddirid;    { info returned above }
  205.                 err := pbgetcatinfo(mycpb, false);        { do it }
  206.                 if err <> noerr then
  207.                     exit(buildpathname);
  208.  
  209.                 {
  210.                 here starts the real work - start to climb the tree by 
  211.                 continually    looking in the iodrparid field for the next 
  212.                 directory above until we fail... 
  213.                 }
  214.                 mycpb^.iodrdirid := mycpb^.iodrparid;    { the first folder}
  215.                 fullpathname      := concat(mycpb^.ionameptr^, ':', filename);
  216.                 
  217.                 repeat
  218.                     mycpb^.iodrdirid := mycpb^.iodrparid;
  219.                     err := pbgetcatinfo(mycpb, false);    { the next level }
  220.  
  221.                     { 
  222.                     be careful of an error returned here - it means the user 
  223.                     chose a file on the desktop level of this volume. if this 
  224.                     is the case, just stop here and return "volumename:filename", 
  225.                     otherwise loop until failure 
  226.                     }
  227.                     
  228.                     if err = noerr then
  229.                         fullpathname := concat(mycpb^.ionameptr^, ':', fullpathname);
  230.  
  231.                 until err <> noerr;
  232.                 
  233.                 disposptr(pointer(mycpb));    { clean up your heap! }
  234.  
  235.                 buildpathname := fullpathname
  236.                 
  237.             end(* build path name *);
  238.             
  239.         begin
  240.         
  241.             with paramptr^ do
  242.                 begin    
  243.                     if paramcount = 2 then
  244.                         begin
  245.                             zerotopas( params[ 1 ]^, prompt );
  246.                             zerotopas( params[ 2 ]^, filename );
  247.                             
  248.                             sfputfile( centerrect( cardrect, dialogrect ), 
  249.                                        prompt, filename, nil, reply );
  250.  
  251.                             if reply.good then
  252.                                 fullpathname := buildpathname( reply.vrefnum, 
  253.                                                                reply.fname );
  254.                         end;
  255.                         
  256.                     returnvalue := pastozero(fullpathname)
  257.                 end
  258.  
  259.         end(* newfilename *);
  260.  
  261. end.